{-# OPTIONS_GHC -fglasgow-exts #-}
module InterlingualHomophones where
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Data.List
import Control.Arrow

-------------------------------------------------------------------------------
-- Type definitions
-------------------------------------------------------------------------------
data InterlingualHomophones where
    InterlingualHomophones :: [ExpressionDec]
                           -> InterlingualHomophones
  deriving (Show,Eq,Ord)

data Language where
    Language :: String -> Language
  deriving (Show,Eq,Ord)

data ExpressionDec where
    ExpressionDec :: Expression
                  -> [Phonetics]
                  -> [Equivalence]
                  -> ExpressionDec
  deriving (Show,Eq,Ord)

data Expression where
    Expression :: Language -> String -> Expression
  deriving (Show,Eq,Ord)

data Phonetics where
    Phonetics :: String -> Phonetics
  deriving (Show,Eq,Ord)

data Equivalence where
    Equivalence :: Expression -> Expression -> Equivalence
  deriving (Show,Eq,Ord)

type PhoneticRelation    = [(Expression,Phonetics)]
type EquivalentsRelation = [(Expression,Expression)]

-------------------------------------------------------------------------------
-- Relational definitions
-------------------------------------------------------------------------------
phoneticRelation :: InterlingualHomophones -> PhoneticRelation
phoneticRelation (InterlingualHomophones ds)
    = nub $ concat $ map (\(ExpressionDec e fs _)->map (\f->(e,f)) fs) ds

equivalentsRelation :: InterlingualHomophones -> EquivalentsRelation
equivalentsRelation (InterlingualHomophones ds)
    = nub $ concat $ map (\(ExpressionDec e _ es) ->
               concat $ map (\(Equivalence _ e2)->[(e,e2),(e2,e)]) es) ds

phRelExprs :: PhoneticRelation -> [Expression]
phRelExprs = nub . map fst

eqRelExprs :: EquivalentsRelation -> [Expression]
eqRelExprs = nub . map fst

relExprs :: PhoneticRelation -> EquivalentsRelation -> [Expression]
relExprs p e = nub $ phRelExprs p ++ eqRelExprs e

getPhonetics :: PhoneticRelation -> Expression -> [Phonetics]
getPhonetics pr e = map snd $ filter ((==e).fst) pr

getEquivalents :: EquivalentsRelation -> Expression -> [Equivalence]
getEquivalents pr e = map ((Equivalence e).snd) $ filter ((==e).fst) pr

exportRelations :: PhoneticRelation
                -> EquivalentsRelation
                -> InterlingualHomophones
exportRelations pr er = InterlingualHomophones $ map f $ sort (relExprs pr er)
    where f e = ExpressionDec e (getPhonetics pr e) (getEquivalents er e)

-------------------------------------------------------------------------------
-- Parser definitions
-------------------------------------------------------------------------------
lexer = P.makeTokenParser (javaStyle
                            {reservedNames=["phonetics","equivalents"]})

whiteSpace = P.whiteSpace lexer
lexeme     = P.lexeme     lexer
colon      = P.colon      lexer
reserved   = P.reserved   lexer

interlingualHomophones = do whiteSpace
                            es <- many1 expressionDec 
                                  <?> "expression declarations"
                            eof
                            return (InterlingualHomophones es)

lang = lexeme $ do l <- many1 (letter <?> "") <?> "language"
                   return (Language l)

expressionDec = do e       <- expression
                   (fs,qs) <- expressionBlock
                   return (ExpressionDec e fs (map (Equivalence e) qs))

expression = lexeme $ do l <- lang
                         char '"'
                         s <- many1 (noneOf "\"") <?> "expression"
                         char '"'
                         return (Expression l s)

expressionBlock = do bs        <- block $ many $ phoneticsBlock
                                             <|> equivalentsBlock
                     (fss,qss) <- return (separateEithers bs)
                     return (concat fss, concat qss)

phoneticsBlock = do lexeme (reserved "phonetics")
                    ps <- block $ many phonetics
                    return (Left ps)

phonetics = lexeme $ do char '['
                        s <- many1 (noneOf "]") <?> "phonetics"
                        char ']'
                        return (Phonetics s)

equivalentsBlock = do lexeme (reserved "equivalents")
                      qs <- block $ many expression
                      return (Right qs)

block p = lexeme $ do lexeme $ char '{'
                      r <- p
                      lexeme $ char '}'
                      return r

word = many1 (letter <?> "") <?> "word"

-------------------------------------------------------------------------------
-- Printer definitions
-------------------------------------------------------------------------------
showHomophones :: InterlingualHomophones -> String

showHomophones (InterlingualHomophones es)
    = concat (map showExpressionDec es)

showExpressionDec (ExpressionDec e fs qs)
    = showExpression e
   ++ if length fs > 0 || length qs > 0
           then " {\n"
             ++ showPhoneticsBlock fs
             ++ showEquivalentsBlock qs
             ++ "}\n"
           else "\n"
   ++ "\n"

showExpression (Expression (Language l) e)
    = l++" \""++e++['"']

showPhoneticsBlock = showBlock 1 "phonetics" showPhonetics

showPhonetics (Phonetics s) = "["++s++"]"

showEquivalentsBlock = showBlock 1 "equivalents" showEquivalence

showEquivalence (Equivalence _ e) = showExpression e

showBlock _ _ _ [] = ""
showBlock i head f items
        = indent i ++ head ++ " {\n"
       ++ concat (map (\x->indent (succ i)++f x++"\n") items)
       ++ indent i ++ "}\n"

indentC = "    "
indent = concat . flip replicate indentC

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
separateEithers = foldr (either (first . (:)) (second . (:))) ([],[])
--                  \es -> ([l | Left l <- es], [r | Right r <- es])
